home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / nexttsrc.lha / nexttsources / sources / sys / unix_bsd4_2.t < prev    next >
Encoding:
Text File  |  1990-06-25  |  9.7 KB  |  286 lines
  1. (herald bsd4_2 (env tsys))
  2.  
  3. (define file-mode/in     #o0)
  4. (define file-mode/out    #o3001)
  5. (define file-mode/append #o1011)
  6.  
  7. (define-constant number-of-signals 27)   ;4.2
  8.  
  9.  
  10. ;;; handler-types (Htype): A = asynchronous, E = exception, D = default,
  11. ;;; I = ignore
  12. ;;; (sig# handler-type handler description)
  13.  
  14. (define *signals*
  15.   '(( 1   D     default         "hangup")
  16.  ;   ( 2   A    sigint-handler    "interrupt")
  17.  ;   ( 3   A    siquit-handler    "quit")
  18.     ( 4   E    non-continuable  "illegal instruction")
  19.     ( 5   E    non-continuable  "trace/BPT trap")
  20.     ( 6   E    non-continuable  "IOT instruction")
  21.     ( 7   E    non-continuable  "EMT instruction")
  22.     ( 8   E    non-continuable  "floating point exception")
  23.  ;   ( 9   D    default          "kill")
  24.     (10   E    non-continuable  "memory protection violation")
  25.     (11   E    non-continuable  "reference to non-existent memory")
  26.     (12   E    non-continuable  "bad argument to a system call")
  27.     (13   E    non-continuable  "broken pipe")
  28.  ;   (14   D    default          "alarm clock")
  29.  ;   (15   A    sigterm-handler   "software termination signal")
  30.  ;   (16   D    default          "urgent condition on socket")
  31.  ;   (17   D    default          "stop")
  32.  ;   (18   D    default          "stop signal generated from keyboard")
  33.  ;   (19   D    default          "continue after stop")
  34.  ;   (20   D    default          "child status has changed")
  35.  ;   (21   D    default          "background read attempted")
  36.  ;   (22   D    default          "background write attempted")
  37.  ;   (23   D    default          "i/o is possible")
  38.     (24   E    non-continuable  "cpu time limit exceeded")
  39.     (25   E    non-continuable  "file size limit exceeded")
  40.   ;  (26   D    default          "virtual time alarm")
  41.   ;  (27   D    default          "profiling timer alarm")
  42.   ))
  43.  
  44. (define-constant %%SIGINT     2)
  45. (define-constant %%SIGQUIT    3)
  46. (define-constant %%SIGTERM    15)
  47. (define-constant %%SIGSTOP    17)
  48.  
  49. ;;; Stop the process and return to it's parent.  The process can be
  50. ;;; re-entered later.
  51.  
  52. (lset stop-system-agenda (make-agenda 'exit-agenda))
  53. (lset continue-system-agenda (make-agenda 'exit-agenda))
  54.  
  55. (define (stop)
  56.   (stop-system-agenda)
  57.   (unix-kill 0 %%sigstop)
  58.   (continue-system-agenda)
  59.   repl-wont-print)
  60.  
  61. (define-foreign unix-kill (kill (in rep/integer)
  62.                                 (in rep/integer))
  63.                 rep/integer)
  64.  
  65. (define-foreign unix-getpid
  66.   (getpid)
  67.   rep/integer)
  68.  
  69. (define-foreign r-nlistone
  70.   (nlistone (in rep/string filename)
  71.         (in rep/string functionName))
  72.   rep/integer)
  73.  
  74. (define-integrable (nlistone file function)
  75.   (r-nlistone (string->asciz! (copy-string file))
  76.           (string->asciz! (copy-string function))))
  77.  
  78.  
  79.  
  80. ;;; loader for foreign code under Unix ... in particular, C
  81. ;;; by Dorab Patel <dorab@neptune.cs.ucla.edu>
  82. ;;; Original: Feb 29, 1984
  83. ;;; Modified for t2.8: May 22, 1984     dorab@neptune.cs.ucla.edu
  84. ;;; Modified for t3: Dec 24, 1986       dorab@neptune.cs.ucla.edu
  85.  
  86. (define (make-foreign-procedure sym)
  87.   (let ((xeno (make-foreign sym))
  88.     (addr (nlistone (check-arg file-exists?
  89.                    (reloc-file)
  90.                    make-foreign-procedure)
  91.             (symbol->string sym))))
  92.        (cond ((fxn= addr 0)
  93.           (set (mref-integer xeno 4) addr)
  94.           xeno)
  95.          (else
  96.           (error "foreign procedure \"~a\" does not exist in file \"~a\""
  97.              (symbol->string sym)
  98.              (reloc-file))))))
  99.  
  100.  
  101. ;;; loader for foreign code under Unix ... in particular, C
  102. ;;; by Dorab Patel <dorab@cs.ucla.edu>
  103. ;;; Original: Feb 29, 1984
  104. ;;; Modified for t2.8: May 22, 1984    dorab@cs.ucla.edu
  105. ;;; Modified for t3: Dec 24, 1986    dorab@cs.ucla.edu
  106. ;;; Bugfix in reloc-file: Dec 23, 1987    dorab@cs.ucla.edu
  107.  
  108. ;;; Copyright Dorab Patel (C) 1984, 1986, 1987, 1988
  109. ;;; Permission is given to distribute this software free to anyone
  110. ;;; using it for a non-commercial purpose as long as the copyright notice
  111. ;;; is maintained.
  112. ;;; Comments/bug reports/fixes are encouraged.
  113.  
  114. ;;; defined in dynload.c
  115. ;;; loads in objfile
  116. ;;; returns 0 if OK, else > 0
  117. ;;; **********************************************************************
  118. (define-foreign r-loadhelp
  119.   (loadhelp (in rep/string objfile)
  120.         (in rep/string relocfile)
  121.         (in rep/string tmpfile)
  122.         (in rep/string libstring)
  123.         (in rep/string otherstring))
  124.   rep/integer)
  125.  
  126. (define-integrable
  127.   (unix-load-help objfile relocfile tmpfile libstring otherstring)
  128.   (r-loadhelp (string->asciz! (copy-string objfile))
  129.           (string->asciz! (copy-string relocfile))
  130.           (string->asciz! (copy-string tmpfile))
  131.           (string->asciz! (copy-string libstring))
  132.           (string->asciz! (copy-string otherstring))))
  133.  
  134. ;;; searchpath is a general utility function that takes a colon-separated
  135. ;;; path list and a filename, and finds the first file that exists in that
  136. ;;; directory list.
  137. ;;; maybe it should be elsewhere ?
  138. ;;; *********************************************************************
  139. (define (searchpath path file)
  140.   (labels (
  141.        ;; convert a colon-separated path into a list.
  142.        ;; empty fields map to the current directory "."
  143.        ;; **********************
  144.        ((splitpath path)
  145.         (iterate
  146.          loop
  147.          ((xpath path) (rv '()))        ; initialization
  148.          (if (string-empty? xpath)        ; if end of loop with colon
  149.          (reverse! (cons "." rv))    ; return with .
  150.          (let ((index (string-posq #\: xpath)))
  151.               (if index        ; if a colon exists
  152.               (if (fx= index 0)
  153.                   (loop (chdr xpath) (cons "." rv))
  154.                   (loop (nthchdr xpath (fx+ index 1))
  155.                     (cons (substring xpath 0 index)
  156.                       rv)))
  157.               (reverse! (cons xpath rv)))))))) ; return from loop
  158.       
  159.       ;; start of searchpath
  160.       ;; *******************
  161.       (if (and (char= (char file) #\slash)        ; if name starts with /
  162.            (file-exists? (->filename file)))    ; and it exists
  163.           file                    ; return it
  164.           (iterate loop ((xpath (splitpath path)))
  165.                (cond ((null? xpath) '#f) ; not found
  166.                  (else (let ((xfile    ; form full path name
  167.                         (string-append (car xpath)
  168.                                    "/"
  169.                                    file)))
  170.                     (if (file-exists? (->filename xfile))
  171.                         xfile
  172.                         (loop (cdr xpath))))))))))
  173.  
  174. ;;; reloc-file contains the full path name of the file containing
  175. ;;; all the namelist information for the currently running Tau process.
  176. ;;; it is used by make-foreign-procedure and load-unix
  177. ;;; (reloc-file) returns the pathname
  178. ;;; (set (reloc-file) val) is used to set the name of the Tau binary to "val"
  179. ;;; (insert reloc-file v) is used to change the value of reloc-file to "v"
  180. ;;; (delete reloc-file nil) is used to delete the current reloc-file
  181. ;;; **********************************************************************
  182. (define reloc-file
  183.   (let ((orig "/usr/local/bin/t")        ; default
  184.     (x "/usr/local/bin/t"))
  185.        (object (lambda () x)
  186.            ((insert self v)
  187.         (set x (enforce string? v)))
  188.            ((delete self v)    ; need two args -- hack!
  189.         (ignore v)
  190.         (or (string-equal? x orig)    ; if not orig
  191.             (not (file-exists? x))    ; and it exists
  192.             (file-delete x)))        ; then delete it
  193.            ((setter reloc-file)
  194.         (lambda (val)
  195.             (set orig (enforce string? val)))))))
  196.  
  197. (define (initialize-local-system)
  198.   (cond ((searchpath (unix-getenv (copy-string "PATH")) 
  199.                      (car (command-line)))
  200.        => (lambda (tau)
  201.           (set (reloc-file) tau)    ; set orig value of reloc-file
  202.           (insert reloc-file tau)    ; set current value
  203.           (insert exit-agenda    ; to remove reloc files on exit
  204.               (lambda () (delete reloc-file nil)))))
  205.   (else (format (error-output)
  206.         "Could not find full path name for ~a~%"
  207.         (car (command-line))))))
  208.  
  209. ;;; This is the function that will be called by a user to load in a compiled
  210. ;;; Unix file.
  211. ;;; returns #t if OK else #f
  212. ;;; **********************************************************************
  213. (define (load-foreign filespec . xoptstrings)
  214.   (labels (
  215.        
  216.        ;; makes a unique file name based on the process id
  217.        ;; ******************************
  218.        (mktemp
  219.         (let ((pid (unix-getpid)))
  220.          (lambda (template)
  221.              (string-append
  222.               template
  223.               (symbol->string (generate-symbol pid))))))
  224.  
  225.        ;; prints the load message
  226.        ;; ******************************
  227.        ((print-load-message name)
  228.         (cond ((print-load-message?)
  229.            (let ((out (standard-output)))
  230.             (comment-indent out (fx* *load-level* 2))
  231.             (format out "Loading ~a~%" name)
  232.             (no-value)))))
  233.  
  234.        ) ; end of labels
  235.       
  236.       ;; the beginning of load-unix
  237.       ;; ******************************
  238.       (let ((pathname (filename->string
  239.                (check-arg file-exists?
  240.                       (->filename filespec)
  241.                       load-unix)))
  242.         (libstring (if xoptstrings
  243.                    (check-arg string? (car xoptstrings) load-unix)
  244.                    ""))
  245.         (otherstring (if (and xoptstrings (cdr xoptstrings))
  246.                  (check-arg string? (cadr xoptstrings) load-unix)
  247.                  ""))
  248.         (tmpfile (check-arg (complement file-exists?)
  249.                     (mktemp "/tmp/dyn")
  250.                     load-unix)))
  251.            (print-load-message pathname)
  252.            (let ((retCode (unix-load-help pathname
  253.                           (check-arg file-exists?
  254.                              (reloc-file)
  255.                              load-unix)
  256.                           tmpfile
  257.                           libstring
  258.                           otherstring)))
  259.             (cond ((fxn= retCode 0)
  260.                (format (error-output)
  261.                    (case retCode
  262.                      ((1) "no space for ld command~%")
  263.                      ((2) "sbrk(0) failed~%")
  264.                      ((3) "could not bump to pagesize~%")
  265.                      ((4) "not page aligned~%")
  266.                      ((5) "ld command too long~%")
  267.                      ((6) "ld command failed~%")
  268.                      ((7) "could not open tmpfile~%")
  269.                      ((8) "cant read header of tmpfile~%")
  270.                      ((9) "bad magic number in tmpfile~%")
  271.                      ((10) "not enough memory~%")
  272.                      ((11) "loadpoint shifted~%")
  273.                      ((12) "memory not page aligned~%")
  274.                      ((13) "fseek fails~%")
  275.                      ((14) "fread fails~%")
  276.                      (else
  277.                       (format nil
  278.                           "no such return value:~d~~%"
  279.                           retCode))))
  280.                '#f)
  281.               (else (delete reloc-file nil)    ; delete old file
  282.                 (insert reloc-file tmpfile) ; set new file
  283.                 '#t))))))
  284.  
  285. ;;; end of dynload.t
  286.